;;########################################################################
;; anovamob.lsp
;; Copyright (c) 1993-99 by Forrest W. Young
;; Nway ViSta Analysis of Variance object. Can fit main effects or two-way 
;; interaction models to n-way balanced or unbalanced univariate data.
;; Data must be complete (no empty cells)
;; uses nway lispstat model object
;;########################################################################

(require "vista")

(defun analysis-of-variance 
  (&key
   (data        current-data)
   (title       "Analysis of Variance")
   (name        nil)
   (dialog      nil)
   (interaction nil))
"ViSta function to perform Analysis of Variance of balanced or unbalanced, complete data. 
With no arguments the current data are analyzed. Keyword arguments are
:INTERACTION followed by t (calculate interaction) or nil (do not calculate, the default);
:DATA followed by the name of the data to be analyzed (default: current-data);
:TITLE followed by a character string (default: Analysis of Variance);
:DIALOG followed by t (to display parameters dialog box) or nil (default)."
  (if (not (eq current-object data)) (setcd data))
  (if (not name) (strcat "ANV-" (send current-data :name)))
  (when (not (send *current-data* :ways))
        (when (not (and (send current-data :active-types '(category))
                        (send current-data :active-types '(numeric))))
              (send *toolbox* :reset-button "ANOVA")
              (fatal-message "ANOVA requires at least one Numeric and at least one Category variable.")))
  (let (;(ok-types '("class" "general"))
        (ok-types '(all));fwy4.29
        )
    (send anova-model-object-proto 
          :new interaction "ANOVA" data title name dialog ok-types)));fwy4.29

(defproto anova-model-object-proto 
  '(nway-model data-object interaction response ways classes 
               profile-labels line-labels line-xs line-ys
               f-obs f-crit leverages nclasses cellfreqs ncells
               class-matrix indicator-matrices nways  ls-means
               level-names source-names nsources)
  () mv-model-object-proto)

(defmeth anova-model-object-proto :isnew 
  (interaction abbrieve data title name dialog ok-types 
               &key response class (hide-icon nil))
  (send self :data-object current-data)
  (send self :model-abbrev "ANV")
  (send self :interaction interaction)
  (send self :ways (send current-data :ways))
  (cond
    ((and response class)
     (send self :response response)
     (send self :classes class)
     (setf dialog nil)
     )
    (t
     (when (send self :ways) 
           (send self :response (first (send self :variables)))
           (send self :classes  (send current-data :classes)))))
  (when hide-icon 
        (send self :hide-analysis-icon t)
        (send self :hide-model-icon t)) 
  (call-next-method abbrieve data title name dialog ok-types)
  )

(defmeth anova-model-object-proto :nway-model (&optional (object-id nil set))
"Message args: (&optional object-id)
Sets or retrieves the object identification information of the underlying nway-model that does the analysis and stores the results."
  (if set (setf (slot-value 'nway-model) object-id))
  (slot-value 'nway-model))

(defmeth anova-model-object-proto :data-object (&optional (object-id nil set))
"Message args: (&optional object-id)
Sets or retrieves the object identification of the analyzed data."
  (if set (setf (slot-value 'data-object) object-id))
  (slot-value 'data-object))

(defmeth anova-model-object-proto :interaction (&optional (logical nil set))
"Method args: (&optional logical)
Sets or returns t or nil indicating whether two-way interaction terms used."
  (if set (setf (slot-value 'interaction) logical))
  (slot-value 'interaction))

(defmeth anova-model-object-proto :response (&optional (string nil set))
"Method args: (&optional string)
Sets or returns response variable name."
  (if set (setf (slot-value 'response) string))
  (slot-value 'response))

(defmeth anova-model-object-proto :class-matrix (&optional (matrix nil set))
"Method args: (&optional matrix)
Sets or returns the matrix of classification data."
  (if set (setf (slot-value 'class-matrix) matrix))
  (slot-value 'class-matrix))

(defmeth anova-model-object-proto :indicator-matrices 
  (&optional (matrix nil set))
"Method args: (&optional matrix)
Sets or returns the matrix of indicator data."
  (if set (setf (slot-value 'indicator-matrices) matrix))
  (slot-value 'indicator-matrices))

(defmeth anova-model-object-proto :ls-means (&optional (list-of-lists nil set))
"Method args: (&optional list-of-lists)
Sets or returns the list of lists of ls-means."
  (if set (setf (slot-value 'ls-means) list-of-lists))
  (slot-value 'ls-means))

(defmeth anova-model-object-proto :ways (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns way names."
  (if set (setf (slot-value 'ways) string-list))
  (slot-value 'ways))

(defmeth anova-model-object-proto :level-names 
  (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns level names."
  (if set (setf (slot-value 'level-names) string-list))
  (slot-value 'level-names))

(defmeth anova-model-object-proto :source-names 
  (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns source names."
  (if set (setf (slot-value 'source-names) string-list))
  (slot-value 'source-names))

(defmeth anova-model-object-proto :ncells (&optional (number nil set))
"Method args: (&optional number)
Sets or returns number of cells."
  (if set (setf (slot-value 'ncells) number))
  (slot-value 'ncells))

(defmeth anova-model-object-proto :nclasses (&optional (number nil set))
"Method args: (&optional number)
Sets or returns number of class variables."
  (if set (setf (slot-value 'nclasses) number))
  (slot-value 'nclasses))

(defmeth anova-model-object-proto :nways (&optional (number nil set))
"Method args: (&optional number)
Sets or returns number of ways."
  (if set (setf (slot-value 'nways) number))
  (slot-value 'nways))

(defmeth anova-model-object-proto :nsources (&optional (number nil set))
"Method args: (&optional number)
Sets or returns number of sources."
  (if set (setf (slot-value 'nsources) number))
  (slot-value 'nsources))

(defmeth anova-model-object-proto :cellfreqs (&optional (number-list nil set))
"Method args: (&optional number-list)
Sets or returns cell frequencies."
  (if set (setf (slot-value 'cellfreqs) number-list))
  (slot-value 'cellfreqs))

(defmeth anova-model-object-proto :classes (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns class names."
  (if set (setf (slot-value 'classes) string-list))
  (slot-value 'classes))

(defmeth anova-model-object-proto :profile-labels
  (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns profile plot x-axis labels."
  (if set (setf (slot-value 'profile-labels) string-list))
  (slot-value 'profile-labels))

(defmeth anova-model-object-proto :line-labels 
  (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns profile plot line labels."
  (if set (setf (slot-value 'line-labels) string-list))
  (slot-value 'line-labels))

(defmeth anova-model-object-proto :line-xs (&optional (number-list nil set))
"Method args: (&optional number-list)
Sets or returns profile plot line label x locations."
  (if set (setf (slot-value 'line-xs) number-list))
  (slot-value 'line-xs))

(defmeth anova-model-object-proto :line-ys (&optional (number-list nil set))
"Method args: (&optional number-list)
Sets or returns profile plot line label y locations."
  (if set (setf (slot-value 'line-ys) number-list))
  (slot-value 'line-ys))

(defmeth anova-model-object-proto :leverages (&optional (matrix nil set))
"Method args: (&optional matrix)
Sets or returns Sall's predictor source variable leverage values."
  (if set (setf (slot-value 'leverages) matrix))
  (slot-value 'leverages))

(defmeth anova-model-object-proto :f-obs (&optional (list nil set))
  (if set (setf (slot-value 'f-obs) list))
  (slot-value 'f-obs))

(defmeth anova-model-object-proto :f-crit (&optional (list nil set))
  (if set (setf (slot-value 'f-crit) list))
  (slot-value 'f-crit))

(defmeth anova-model-object-proto :options ()
"Args: none
Constructs and displays the options dialog window for ANOVA. Returns nil if dialog canceled or when no response and/or classification variables selected from multivariate data. Otherwise returns a three element list consisting of the name of the response variable, a list of the names of the classifier variables, and a 0 for no interaction or 1 for two-way interactions."
  (cond 
    ((send self :ways)
     (error-message "ANOVA OPTIONS: Table data ng.")
     (send self :options-table)
     )
    (t
     (let* ((result 
             (if (and (= 1 (send self :active-nvar '(numeric)))
                      (= 1 (send self :active-nvar '(category))))
                 (list (first (send self :active-variables '(numeric)))
                       (send self :active-variables '(category))
                       0)
                 (send self :options-mv)))
            (response-variable-name (first result))
            (cat-variables (second result))
            (interaction (third result))
            (nobs (send self :nobs))
            (cat-matrix nil)
            (cell-labels nil)
            (data-matrix nil)
            (sorted-labels-and-grouped-data nil)
            )
       (when result
             (cond
              ((or (< (length response-variable-name) 1)
                   (< (length cat-variables) 1))
               (setf result nil)
               (error-message "You must select one response variable and at least one classification variable."))
               (t
                (if (= 0 interaction)
                    (send self :interaction nil)
                    (send self :interaction t))
                (send self :ways cat-variables)
                (setf cat-matrix
                      (bind-columns 
                       (send self :variable (select cat-variables 0))))
                (when (> (length cat-variables) 1)
                  (dotimes (i (1- (length cat-variables)))
                     (setf cat-matrix (bind-columns 
                           cat-matrix
                          (send self :variable 
                                (select cat-variables (1+ i)))))))
                (send self :classes
                      (mapcar #'(lambda (x)
                                  (coerce (remove-duplicates
                                           (send self :variable x) 
                                           :test #'equal) 'list)) 
                              cat-variables))
                (send self :nclasses
                      (mapcar #'length (send self :classes)))
                (setf cell-labels (make-cell-labels cat-matrix cat-variables))
                (setf data-matrix (bind-columns
                          (send self :variable response-variable-name)
                          cat-matrix))
                (setf sorted-labels-and-grouped-data 
                      (sort-labels-and-group-data cell-labels data-matrix))
                (send self :labels (first sorted-labels-and-grouped-data))
                (send self :data (second sorted-labels-and-grouped-data))
                (send self :classes (third sorted-labels-and-grouped-data))
                (send self :class-matrix 
                      (select (fourth sorted-labels-and-grouped-data)
                              (iseq nobs) (iseq 1 (length cat-variables))))
                (send self :cellfreqs (mapcar #'length (send self :data)))
                (send self :ncells (length (send self :cellfreqs)))
                (send self :response response-variable-name)
                (send self :nways (length (send self :ways))) 
                (send self :make-level-names)
                )))
       result))))

(defmeth anova-model-object-proto :options-table () 
  (let ((choice t))
    (when (send self :dialog)
          (when (or (> (send current-data :nways) 2)
                    (and (= (send current-data :nways) 2)
                         (> (send current-data :nobs) 
                            (send current-data :ncells))))
                (setf choice (choose-item-dialog 
                        "Analysis of Variance:
Include Two-Way Interaction Terms?"
                              '("Main Effects Only (No Interactions)"
                                "Main Effects and Two-Way Interactions")))
                (when choice
                      (if (= 0 choice)
                          (send self :interaction nil)
                          (send self :interaction t))))
          choice)))

(defmeth anova-model-object-proto :options-mv ()
"Args: none
Constructs and displays the options dialog window for ANOVA models of MV data.
Returns nil when dialog canceled. Returns three element list otherwise.  The first element of the list is the name of the response variable.  The second element is a list of the names of the classifier variables. The third element is 0 if no interactions are to be computed, 1 if interactions are to be computed. If dialog=nil, then the response variable is the first numeric variable in the dataset, the classifier variables are all of the nominal variables in the dataset, and interactions are computed."
          
  (let* ((no-dialog-response-variable 
          (first (send self :active-variables '(numeric))))
         (no-dialog-class-variables 
          (send self :active-variables '(category)))
         (box-text-item (send text-item-proto :new 
                              "Analysis of Variance:"))
         (method-toggle (send choice-item-proto :new (list 
                 "Main Effects Only (No Interactions)"
                 "Main Effects and Two-Way Interactions")))
         (rsp-text-item1 (send text-item-proto :new 
                 (format nil "Selectable~%Numeric Variables")))
         (rsp-text-item2 (send text-item-proto :new 
                 (format nil "Selected~%Response Variable")))
         (cls-text-item1 (send text-item-proto :new 
                 (format nil "Selectable~%Class Variables")))
         (cls-text-item2 (send text-item-proto :new 
                 (format nil "Selected~%Class Variables")))
         (var-list (send self :active-variables '(numeric)))
         (cls-list (send self :active-variables '(category)))
         (var-list-item (send list-item-proto :new var-list))
         (rsp-var (send list-item-proto :new (list " ") ))
         (cls-list-item (send list-item-proto :new cls-list))
         (method nil)
         (selected-class-variables nil)
         (selected-response-variable nil)
         (cls-var (send list-item-proto :new (repeat " " (length cls-list))))
         (ok        (send modal-button-proto :new "OK"))
         (cancel    (send modal-button-proto :new "Cancel"))
         (reg-dialog 
          (when (send self :dialog)
                (if (> (length cls-list) 1) 
                    (send modal-dialog-proto :new
                          (list box-text-item
                                (list (list rsp-text-item1 var-list-item) 
                                      (list rsp-text-item2 rsp-var))
                                (list (list cls-text-item1 cls-list-item) 
                                      (list cls-text-item2 cls-var))
                                method-toggle
                                (list ok cancel))
                          :default-button ok)
                    (send modal-dialog-proto :new
                          (list box-text-item
                                (list (list rsp-text-item1 var-list-item) 
                                      (list rsp-text-item2 rsp-var))
                                (list (list cls-text-item1 cls-list-item) 
                                      (list cls-text-item2 cls-var))
                                (list ok cancel))
                          :default-button ok))))
          
         )
    (defmeth cancel :do-action ()
      (let ((dialog (send cancel :dialog)))
        (send dialog :modal-dialog-return nil)))
    (defmeth ok :do-action ()
      (let ((dialog (send ok :dialog)))
        (if (> (length cls-list) 1) 
            (setf method (send method-toggle :value))
            (setf method 0))
        (setf selected-class-variables
              (concatenate 'list
                           (send cls-var :slot-value 'list-data)))
        (setf selected-response-variable
              (first (concatenate 'list
                                  (send rsp-var :slot-value 'list-data))))
        (send dialog :modal-dialog-return t)))
                          
    (when reg-dialog
          ;following required for reg-dialog to work
          (send rsp-var :slot-value 'list-data #())
          (send cls-var :slot-value 'list-data #())
          (defmeth reg-dialog :switch-element 
            (me you your-max-L)
            (let* ((n (send me :selection))
                   (my-list   (send me  :slot-value 'list-data))
                   (your-list (send you :slot-value 'list-data))
                   (L-me  (length my-list))
                   (L-you (length your-list))
                   (s nil))
              (when n
                    (send me :selection nil)
                    (when (and (< n L-me) (< L-you your-max-L))
                          (setf s (select my-list n))
                          (when (< n (1- L-me))
                                (dolist (i (iseq n (- L-me 2)))
                                        (send me :set-text i 
                                              (select my-list (1+ i)))))
                          (send me :set-text (1- L-me) " ")
                          (send me :slot-value 'list-data
                                (select (send me :slot-value 'list-data) 
                                        (iseq (1- L-me))))
                          (send you :slot-value 'list-data
                                (concatenate 'vector your-list (vector s)))
                          (send you :set-text L-you s)))))

          (defmeth var-list-item :do-action (&optional dbl-clk)
            (send  reg-dialog :switch-element 
                   var-list-item rsp-var 1))
          (defmeth rsp-var :do-action (&optional dbl-clk)
            (send  reg-dialog :switch-element 
                   rsp-var var-list-item (length var-list)))
          (defmeth cls-list-item :do-action (&optional dbl-clk)
            (send  reg-dialog :switch-element 
                   cls-list-item cls-var (length cls-list)))
          (defmeth cls-var :do-action (&optional dbl-clk)
            (send  reg-dialog :switch-element 
                   cls-var cls-list-item (length cls-list))))
    (send self :dialog-objid reg-dialog)
    (cond 
      (reg-dialog
       (if (send reg-dialog :modal-dialog);t if OK, nil if Cancel
           (list selected-response-variable 
                 selected-class-variables
                 method)))
      (t
       (list no-dialog-response-variable
             no-dialog-class-variables
             1)))
    ))

(defmeth anova-model-object-proto :analysis ()
  (when (/= (length (send self :data))
            (apply #'* (mapcar #'length (send self :classes))))
        (fatal-message "This analysis cannot be performed because one or more of the data cells contains no data."))
  (let* ((interaction (send self :interaction))
         (dob (send self :data-object))
         (object nil)
         (testval nil))
    (when (send dob :ways) 
          (send self :nways (send dob :nways))
          (send self :cellfreqs (send dob :cellfreqs)))
    (setf testval (remove-duplicates (send self :cellfreqs)))
    (when (and interaction
               (= (length testval) 1) 
               (= (first testval) 1) 
               (< (send self :nways) 3))
          (send self :interaction nil)
          (setf interaction nil)
          (error-message "Interaction effects not estimated for one-way or two-way data when there is only one observation for every cell."))
    (when (and (= 1 (length (send self :ways))) interaction) 
          (error-message "Interactions not possible with one classification variable. Analysis continues without interactions.") 
          (send self :interaction nil) 
          (setf interaction nil))
    (setf object (nway-model (send self :data) 
                             :class-names (send self :classes)
                             :way-names (send self :ways)
                             :print nil
                             :interaction interaction))
    (send self :nway-model object)
    (send self :indicator-matrices (send object :indicator-matrices))
    (when (send dob :ways)
          (send self :response (first (send dob :variables)))
          (send self :class-matrix)
          (send self :nobs (send dob :nobs))
          (send self :nclasses (send dob :nclasses))
          (send self :classes (send dob :classes))
          (send self :level-names (send dob :level-names))
          (send self :ncells (send dob :ncells)))
    (when interaction
          (send self :indicator-matrices 
                (send self :make-interaction-indicator-matrices)))
    (send self :make-source-names)
    (send self :nsources
          (if interaction
              (length (send self :source-names))
              (send self :nways)))
    (when (not interaction)
          (send self :source-names 
                (select (send self :source-names) 
                        (iseq (send self :nways))))
          (send self :level-names
                (select (send self :level-names)
                        (iseq (send self :nways)))))
    (send self :leverages (send self :make-leverages))
    (send self :ls-means (send self :make-lsmeans))
    object))


(defmeth anova-model-object-proto :interpret-model (&optional (flush t))
  (send self :report :interpret t :flush flush))

  

(defmeth anova-model-object-proto :report (&key (dialog nil) (interpret nil) (flush t) )
  (if (not (eq current-object self)) (setcm self))
  (let* ((object (send self :nway-model))
         (w nil)
         (details (list '(0)))
         (dob (send self :data-object))
         (nclasses (send self :nclasses))
         (nways (send self :nways))
         (ls-means (send self :ls-means))
         (max-ls-mean (max ls-means))
         (num-sig (length (format nil "~a" (truncate max-ls-mean))))
         (level-names (send self :level-names))
         (max-level-l (+ 3 (max (mapcar #'length (combine level-names)))))
         (max-source-l (max (mapcar #'length (send self :source-names))))
         (padding (apply #'strcat 
              (repeat " " (max 21 max-level-l max-source-l))))
         (paddots (apply #'strcat (repeat "." (length padding))))
         (num-print-cols nil)
         (n-cols)
         (print-2way)
         (source-names 
          (mapcar #'(lambda (name)
                      (select (strcat name paddots) (iseq (length paddots))))
                  (send self :source-names)))
         )
    (unless interpret
            (when dialog 
                  (setf details (choose-subset-dialog "ANOVA Report Options"
                           (select (list "LS Means" "Parameter Estimates"
                                         "Fit Summary" "Model Effects")
                                   (iseq (if (> nways 1) 4 3))) :initial '(2)))
                  (setf details (if (not details) (top-level) (first details)))) 
            (setf w (report-header (send self :title)))
             (display-string (format nil "ANALYSIS OF VARIANCE of the ~a data~2%"
                            (send dob :name)) w)
            (send self :analysis-options-and-details w)
            (when (member 0 details)
                  (if (> nways 1)
                      (dotimes (i nways)
                        (dolist (j (iseq i (1- nways)))
                           (setf num-print-cols 
                                 (append num-print-cols (list (select nclasses j))))))
                      (setf num-print-cols (list (list (select nclasses 0)))))
                  (display-string 
                   (format nil "~2%LEAST-SQUARES MEANS:") w)
                  (dotimes (i (length ls-means))
                           (display-string (format nil "~%~a" (select source-names i)) w)
                           (setf n-cols (select num-print-cols i))
                           (mapcar #'(lambda (label ls-mean i) 
                                       (setf label (reverse (select (reverse (strcat paddots label)) 
                                                                    (iseq max-level-l))))
                                       (when (and (> i 0) (= (mod i n-cols) 0))
                                           (display-string (format nil "~%~a" padding) w))
                                       (display-string 
                                        (format nil "~va=~v,2f" max-level-l label 
                                                (+ 3 num-sig) ls-mean) w))
                                   (select level-names i) (select ls-means i) 
                                   (iseq (length (select ls-means i))))))
            (display-string (format nil "~2%RESULTS:~%") w))
    (send object :display w details self nil interpret flush)
    (unless interpret (send w :fit-window-to-text))))
    
(defmeth anova-model-object-proto :analysis-options-and-details (w &optional (flush t))
"Args: WINDOW &OPTIONAL (FLUSH T)
Displays information about the choosen options and the details of the analysis in WINDOW, optionally FLUSHing the window first. Used by REPORT for header information, and by ABOUT-THIS-MODEL for analysis summary information."

;this method is needed by this name for model-about-info to work right.
;also should be used by report method as the header
;must have argument w to tell which window (report, about) info goes to

  (let* ((dob (send self :data-object))
         (nclasses (send self :nclasses))
         (cellfreqs (send self :cellfreqs))
         (ncells (send self :ncells))
         (nobs (send self :nobs))
         (nways (send self :nways))
         (balanced (= 1 (length (remove-duplicates cellfreqs))))
         (str (list (strcat (send self :response) " = linear function of ")))
         (resp-name-l (length (first str)))
         (str (append str (mapcar #'(lambda (str) (strcat str " + " )) 
                                       (send self :source-names))))
         (num-print-cols 0)
         )
    (when flush (send w :flush-window))
    (display-string (format nil  "Model:~%") w)
    (setf str (reverse str))
    (setf (select str 0) (select (select str 0) (iseq (- (length (select str 0)) 3))))
    (setf str (reverse str))
    (dotimes (i (length str))
             (display-string (format nil "~a" (select str i)) w)
             (setf num-print-cols (+ num-print-cols (length (select str i))))
             (when (> num-print-cols 70) 
                   (setf num-print-cols resp-name-l)
                   (display-string (format nil "~%~a" 
                                           (apply #'strcat (repeat " " resp-name-l))) w)))
    (display-string (format nil  "~2%Response  Variable:       ~a~%" 
                            (send self :response))   w)
    (display-string (format nil  "Way Names:                ~a~%"
                            (send self :ways)) w)
    (when (> nways 1) (display-string (format nil  "Two-Way Interactions?     ~a~%" 
                                  (if (send self :interaction) "Yes" "No")) w))
    (display-string (format nil "~%Number of Classes:        ~f~%" nclasses) w)
    (display-string (format nil   "Class Names:              ~a~%" (send self :classes)) w)
    (display-string (format nil   "Number of Observations:   ~d~%" nobs) w)
    (display-string (format nil   "Number of Cells:          ~d~%" ncells) w)
    (if balanced
        (display-string 
         (format nil "All Cell Frequencies Are: ~a~%" (first cellfreqs)) w)
        (display-string (format nil   "Cell Frequencies:         ~f~%" cellfreqs) w))
    (display-string (format nil   "Design Type:              ") w)
    (if balanced (display-string (format nil "Balanced~%") w)
        (display-string (format nil "Unbalanced") w))
    ))

#|
(require (strcat *vista-dir-name* "anovamoc"))
(require (strcat *vista-dir-name* "nway"))
(require (strcat *vista-dir-name* "anovavis"))

(provide "anovamob")

|#